Pascal Super Library/Pascal Super Library (CW International)(1997).bin/STRINGS/TPWRST/TPWRDSTR.PAS

Pascal/Delphi Source File | 1990-03-28 | 20KB | 685 lines

{$S-,R-,V-,I-,B-,F+}

{$IFNDEF Ver40}
  {$I OPLUS.INC}
{$ENDIF}

{*********************************************************}
{*                  TPWRDSTR.PAS 1.0                     *}
{*          Copyright (c) Ken Henderson 1990.            *}
{*                                                       *}
{*                                                       *}
{*                 All rights reserved.                  *}
{*********************************************************}

unit TPWrdStr;
  {-Routines to support strings which use a word in the place of Turbo Pascal's
    byte for holding the length of a string -- theoretically allowing strings
    as large as 64k.}

interface

uses
  TpString;

const
  MaxWrdStr = 1024;          {Maximum length of WrdStr - increase up to 65519}
  NotFound = 0;              {Returned by the Pos functions if substring not found}

type
  WrdStr = array[-1..MaxWrdStr] of Char;
  WrdStrPtr = ^WrdStr;

function WrdStr2Str(var A : WrdStr) : string;
  {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}

procedure Str2WrdStr(S : string; var A : WrdStr);
  {-Convert a Turbo string into an WrdStr}

function LenWrdStr(A : WrdStr) : Word;
  {-Return the length of an WrdStr string}

procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);
  {-Return a substring of a. Note start=1 for first char in a}

procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);
  {-Delete len characters of a, starting at position start}

procedure ConcatWrdStr(var A, B, C : WrdStr);
  {-Concatenate two WrdStr strings, returning a third}

procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);
  {-Concatenate a string to an WrdStr, returning a new WrdStr}

procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);
  {-Insert WrdStr obj at position start of a}

procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);
  {-Insert string obj at position start of a}

function PosStr(Obj : string; var A : WrdStr) : Word;
  {-Return the position of the string obj in a, returning NotFound if not found}

function PosWrdStr(var Obja, A : WrdStr) : Word;
  {-Return the position of obja in a, returning NotFound if not found}

function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;
  {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}

procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);
  {-Return an WrdStr from the heap, empty if pointer is nil}

procedure DisposeWrdStr(P : WrdStrPtr);
  {-Dispose of heap space pointed to by P}

function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;
  {-Read an WrdStr from text file, returning true if successful}

function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;
  {-Write an WrdStr to text file, returning true if successful}

procedure WrdStrUpcase(var A, B : WrdStr);
  {-Uppercase the WrdStr in a, returning b}

procedure WrdStrLocase(var A, B : WrdStr);
  {-Lowercase the WrdStr in a, returning b}

procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);
  {-Return an WrdStr of length len filled with ch}

procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
  {-Right-pad the WrdStr in a to length len with ch, returning b}

procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);
  {-Right-pad the WrdStr in a to length len with blanks, returning b}

procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
  {-Left-pad the WrdStr in a to length len with ch, returning b}

procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);
  {-Left-pad the WrdStr in a to length len with blanks, returning b}

procedure WrdStrTrimLead(var A, B : WrdStr);
  {-Return an WrdStr with leading white space removed}

procedure WrdStrTrimTrail(var A, B : WrdStr);
  {-Return an WrdStr with trailing white space removed}

procedure WrdStrTrim(var A, B : WrdStr);
  {-Return an WrdStr with leading and trailing white space removed}

procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);
  {-Return an WrdStr centered in an WrdStr of Ch with specified width}

procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);
  {-Return an WrdStr centered in an WrdStr of blanks with specified width}

function CompWrdStr(var a1, a2 : WrdStr) : Boolean;
  {-Return equivalence of a1 and a2}

  {==========================================================================}

implementation
const
 Blank : char = #32;

  function WrdStr2Str(var A : WrdStr) : string;
    {-Convert WrdStr to Turbo string, truncating if longer than 255 chars}
  var
    S : string;
    Len : Word absolute A;
    Slen : byte Absolute S;
  begin
    if Len > 255 then SLen := 255
    else Slen := Len;
    Move(A[1], S[1], SLen);
    WrdStr2Str := S;
  end;

  procedure Str2WrdStr(S : string; var A : WrdStr);
    {-Convert a Turbo string into an WrdStr}
  var
    slen : byte absolute S;
    alen : word absolute A;
  begin
    Move(S[1], A[1], slen);
    alen := slen;
  end;

  function LenWrdStr(A : WrdStr) : Word;
    {-Return the length of an WrdStr string}
  var
    alen : Word absolute A;
  begin
    LenWrdStr := alen;
  end;

  procedure CopyWrdStr(var A : WrdStr; Start, Len : Word; var O : WrdStr);
    {-Return a substring of a. Note start=1 for first char in a}
  var
    alen : Word absolute A;
    olen : Word absolute O;
  begin
    if Start > alen then
      Olen := 0
    else begin
      {Don't copy more than exists}
      if Start+Len > alen then
        Len := Succ(alen-Start);
      Move(A[Start], O[1], Len);
      Olen := Len;
    end;
  end;

  procedure DeleteWrdStr(var A : WrdStr; Start, Len : Word);
    {-Delete len characters of a, starting at position start}
  var
    alen : Word Absolute A;
    mid : Word;
  begin
    if Start <= alen then begin
      {Don't do anything if start position exceeds length of string}
      mid := Start+Len;
      if mid <= alen then begin
        {Move right remainder of string left}
        Move(A[mid], A[Start], len);
        Dec(alen,len);
      end else
        {Entire end of string deleted}
        alen := Pred(Start);
    end;
  end;

  procedure ConcatWrdStr(var A, B, C : WrdStr);
    {-Concatenate two WrdStr strings, returning a third}
  var
    alen : Word absolute A;
    blen : Word absolute B;
    clen : Word absolute C;
    temp : Word;
  begin

    {Put a into the result}
    Move(A[1], C[1], alen);

    {Store as much of b as fits into result}
    Temp := blen;
    if alen+blen > MaxWrdStr then
      Temp := MaxWrdStr-alen;
    Move(B[1], C[Succ(alen)], Temp);

    {Terminate the result}
    clen := alen+blen;
  end;

  procedure ConcatStr(var A : WrdStr; S : string; var C : WrdStr);
    {-Concatenate a string to an WrdStr, returning a new WrdStr}
  var
    alen : Word absolute A;
    clen : Word absolute C;
    slen : Byte absolute S;
  begin

    {Put a into the result}
    Move(A[1], C[1], alen);

    {Store as much of s as fits into result}
    if alen+slen > MaxWrdStr then
      slen := MaxWrdStr-alen;
    Move(S[1], C[succ(alen)], slen);

    {Terminate the result}
    clen := alen+slen;
  end;

  procedure InsertWrdStr(var Obj, A : WrdStr; Start : Word);
    {-Insert WrdStr obj at position start of a}
  var
    alen : Word absolute A;
    olen : Word absolute Obj;
    mid, temp : Word;
  begin

    if Start > alen then
      {Concatenate if start exceeds alen}
      Start := Succ(alen)

    else begin
      {Move right side characters right to make space for insert}
      mid := Start+olen;
      if mid <= MaxWrdStr then
        {Room for at least some of the right side characters}
        if alen+olen <= MaxWrdStr then
          {Room for all of the right side}
          Move(A[Start], A[mid], Succ(alen-Start))
        else
          {Room for part of the right side}
          Move(A[Start], A[mid], Succ(MaxWrdStr-mid));
    end;

    {Insert the obj string}
    temp := Olen;
    if Start+olen > MaxWrdStr then
      temp := Succ(MaxWrdStr-Start);
    Move(Obj[1], A[Start], temp);

    {Terminate the string}
    if alen+olen <= MaxWrdStr then
      Inc(alen,olen)
    else
      alen := MaxWrdStr;
  end;

  procedure InsertStr(Obj : string; var A : WrdStr; Start : Word);
    {-Insert string obj at position start of a}
  var
    alen : Word absolute A;
    olen : byte absolute Obj;
    mid,temp : Word;
  begin

    if Start > alen then
      {Concatenate if start exceeds alen}
      Start := succ(alen)

    else begin
      {Move right side characters right to make space for insert}
      mid := Start+olen;
      if mid <= MaxWrdStr then
        {Room for at least some of the right side characters}
        if alen+olen <= MaxWrdStr then
          {Room for all of the right side}
          Move(A[Start], A[mid], Succ(alen-Start))
        else
          {Room for part of the right side}
          Move(A[Start], A[mid], Succ(MaxWrdStr-mid));
    end;

    {Insert the obj string}
    temp := olen;
    if Start+olen > MaxWrdStr then
      temp := Succ(MaxWrdStr-Start);
    Move(Obj[1], A[Start], temp);

    {Terminate the string}
    if alen+olen <= MaxWrdStr then
      Inc(alen,olen)
    else
      alen := MaxWrdStr;
  end;

  {$L TPWrdStr}
  function Search(var Buffer; BufLength : Word; var Match; MatLength : Word) : Word;
    external;
  procedure WrdStrUpcase(var A, B : WrdStr);
    {-Upper case WrdStr A, returning it in B}
  var
    alen : Word absolute A;
    x : Word;
  begin
    For x:=1 to alen do A[x]:=UpCase(A[x]);
    Move(A,B,alen+2);
  end;
  procedure WrdStrLocase(var A, B : WrdStr);
    {-Lower case WrdStr A, returning it in B}
  var
    alen : Word absolute A;
    x : Word;
  begin
    For x:=1 to alen do A[x]:=LoCase(A[x]);
    Move(A,B,alen+2);
  end;

  function CompWrdStr(var a1, a2 : WrdStr) : Boolean;
    {-Compare WrdStr's a1 and a2 and return equivalence}
  var
   alen1 : Word absolute A1;
   alen2 : Word absolute A2;
   x : Word;
  begin
    CompWrdStr := false;
    If (alen1=alen2) then  {possibly equal, let's check it out}
    begin
      for x:=1 to alen1 do if (A1[x]<>A2[x]) then exit;
      CompWrdStr := true;  {If we made it to here, they must be equal}
    end;
  end;

  function PosStr(Obj : string; var A : WrdStr) : Word;
    {-Return the position of the string obj in a, returning NotFound if not found}
  var
    alen : Word absolute A;
    olen : Byte absolute Obj;
    PosFound : Word;
  begin
    PosFound := Search(A[1], alen, Obj[1], olen);
    If (PosFound = $FFFF) then {Search didn't find it}
       PosFound := 0;
    PosStr := Succ(PosFound);
  end;

  function PosWrdStr(var Obja, A : WrdStr) : Word;
    {-Return the position of obja in a, returning NotFound if not found}
  var
    alen : Word absolute A;
    olen : Word absolute Obja;
    PosFound : Word;
  begin
    PosFound := Search(A[1], alen, Obja[1], olen);
    If (PosFound = $FFFF) then {Search didn't find it}
       PosFound := 0;
    PosWrdStr := Succ(PosFound);
  end;

  function WrdStrToHeap(var A : WrdStr) : WrdStrPtr;
    {-Put WrdStr on heap, returning a pointer, nil if insufficient memory}
  var
    alen : Word;
    P : WrdStrPtr;
  begin
    alen := LenWrdStr(A)+2;
    if MaxAvail >= alen then begin
      GetMem(P, alen);
      Move(A, P^, alen);
      WrdStrToHeap := P;
    end else
      WrdStrToHeap := nil;
  end;

  procedure WrdStrFromHeap(P : WrdStrPtr; var A : WrdStr);
    {-Return an WrdStr from the heap, empty if pointer is nil}
  var
    alen : Word absolute a;
    plen : Word absolute p;
  begin
    if P = nil then
      Alen := 0
    else
      Move(P^, A, Plen+2);
  end;

  procedure DisposeWrdStr(P : WrdStrPtr);
    {-Dispose of heap space pointed to by P}
  begin
    if P <> nil then
      FreeMem(P, LenWrdStr(P^)+2);
  end;

  procedure WrdStrCharStr(Ch : Char; Len : Word; var A : WrdStr);
    {-Return an WrdStr of length len filled with ch}
  var
    alen : Word absolute A;
  begin
    if Len = 0 then
      Alen := 0
    else begin
      if Len > MaxWrdStr then
        Len := MaxWrdStr;
      FillChar(A[1], Len, Ch);
      Alen := Len;
    end;
  end;

  procedure WrdStrPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
    {-Right-pad the WrdStr to length len with ch, returning b}
  var
    alen : Word Absolute A;
    blen : Word Absolute B;
  begin
    if alen >= Len then
      {Return the input string}
      Move(A, B, alen+2)
    else begin
      if Len > MaxWrdStr then
        Len := MaxWrdStr;
      Move(A[1], B[1], alen);
      FillChar(B[succ(alen)], Len-alen, Ch);
      Blen := len;
    end;
  end;

  procedure WrdStrPad(var A : WrdStr; Len : Word; var B : WrdStr);
    {-Right-pad the WrdStr to length len with blanks, returning b}
  begin
    WrdStrPadCh(A, Blank, Len, B);
  end;

  procedure WrdStrLeftPadCh(var A : WrdStr; Ch : Char; Len : Word; var B : WrdStr);
    {-Left-pad the WrdStr in a to length len with ch, returning b}
  var
    alen : Word absolute A;
    blen : Word absolute B;
  begin
    if alen >= Len then
      {Return the input string}
      Move(A, B, alen+2)
    else begin
      FillChar(B[1], Len-alen, Ch);
      Move(A[1], B[Succ(Len-alen)], alen);
      BLen := Len;
    end;
  end;

  procedure WrdStrLeftPad(var A : WrdStr; Len : Word; var B : WrdStr);
    {-Left-pad the WrdStr in a to length len with blanks, returning b}
  begin
    WrdStrLeftPadCh(A, Blank, Len, B);
  end;

  procedure WrdStrTrimLead(var A, B : WrdStr);
    {-Return an WrdStr with leading white space removed}
  var
    alen : Word absolute A;
    apos : Word;
  begin
    apos := 1;
    while (apos < alen) and (A[apos] <= Blank) do
      Inc(apos);
    Move(A[apos], B[1], Succ(alen-apos));
  end;

  procedure WrdStrTrimTrail(var A, B : WrdStr);
    {-Return an WrdStr with trailing white space removed}
  var
    alen : Word absolute A;
    blen : Word absolute B;
  begin
    while (alen > 1) and (A[Pred(alen)] <= Blank) do
      Dec(alen);
    Move(A, B, alen+2);
  end;

  procedure WrdStrTrim(var A, B : WrdStr);
    {-Return an WrdStr with leading and trailing white space removed}
  var
    blen : Word Absolute B;
  begin
    WrdStrTrimLead(A, B);
    while (blen > 1) and (B[Pred(blen)] <= Blank) do
      Dec(blen);
  end;

  procedure WrdStrCenterCh(var A : WrdStr; Ch : Char; Width : Word; var B : WrdStr);
    {-Return an WrdStr centered in an WrdStr of Ch with specified width}
  var
    alen : Word absolute A;
    blen : Word absolute B;
  begin
    if alen >= Width then
      {Return input}
      Move(A, B, alen+2)
    else begin
      FillChar(B[1], Width, Ch);
      Move(A[1], B[Succ((Width-alen) shr 1)], alen);
      Blen := Width;
    end;
  end;

  procedure WrdStrCenter(var A : WrdStr; Width : Word; var B : WrdStr);
    {-Return an WrdStr centered in an WrdStr of blanks with specified width}
  begin
    WrdStrCenterCh(A, Blank, Width, B);
  end;

type
  {text buffer}
  TextBuffer = array[0..65520] of Byte;

  {structure of a Turbo File Interface Block}
  FIB = record
          Handle : Word;
          Mode : Word;
          BufSize : Word;
          Private : Word;
          BufPos : Word;
          BufEnd : Word;
          BufPtr : ^TextBuffer;
          OpenProc : Pointer;
          InOutProc : Pointer;
          FlushProc : Pointer;
          CloseProc : Pointer;
          UserData : array[1..16] of Byte;
          Name : array[0..79] of Char;
          Buffer : array[0..127] of Char;
        end;

const
  FMClosed = $D7B0;
  FMInput = $D7B1;
  FMOutput = $D7B2;
  FMInOut = $D7B3;
  CR : Char = ^M;

  function ReadLnWrdStr(var F : Text; var A : WrdStr) : Boolean;
    {-Read an WrdStr from text file, returning true if successful}
  var
    CrPos : Word;
    alen : Word absolute A;
    blen : Word;

    function RefillBuf(var F : Text) : Boolean;
      {-Refill buffer}
    var
      Ch : Char;
    begin
      with FIB(F) do begin
        BufEnd := 0;
        BufPos := 0;
        Read(F, Ch);
        if IoResult <> 0 then begin
          {Couldn't read from file}
          RefillBuf := False;
          Exit;
        end;
        {Reset the buffer again}
        BufPos := 0;
        RefillBuf := True;
      end;
    end;


  begin
    with FIB(F) do begin

      {Initialize the WrdStr length and function result}
      alen := 0;
      ReadLnWrdStr := False;

      {Make sure file open for input}
      if Mode <> FMInput then
        Exit;

      {Make sure something is in buffer}
      if BufPos >= BufEnd then
        if not(RefillBuf(F)) then
          Exit;

      {Use the Turbo text file buffer to build the WrdStr}
      repeat

        {Search for the next carriage return in the file buffer}
        CrPos := Search(BufPtr^[BufPos], Succ(BufEnd-BufPos), CR, 1);

        if CrPos = $FFFF then begin
          {CR not found, save the portion of the buffer seen so far}
          blen := BufEnd-BufPos;
          if alen+blen > MaxWrdStr then
            blen := MaxWrdStr-alen;

          Move(BufPtr^[BufPos], A[alen], blen);
          Inc(alen, blen);

          {See if at end of file}
          if eof(F) then begin
            {Force exit with this line}
            CrPos := 0;
            {Remove trailing ^Z}
            while (alen > 1) and (A[Pred(alen)] = ^Z) do
              Dec(alen);
          end else if not(RefillBuf(F)) then
            Exit;

        end else begin
          {Save up to the CR}
          blen := CrPos;
          if alen+blen > MaxWrdStr then
            blen := MaxWrdStr-alen;
          Move(BufPtr^[BufPos], A[alen], blen);
          Inc(alen, blen);

          {Inform Turbo we used the characters}
          Inc(BufPos, Succ(CrPos));

          {Skip over following ^J}
          if BufPos < BufEnd then begin
            {Next character is within current buffer}
            if BufPtr^[BufPos] = Ord(^J) then
              Inc(BufPos);
          end else begin
            {Next character is not within current buffer}
            {Refill the buffer}
            if not(RefillBuf(F)) then
              Exit;
            if BufPos < BufEnd then
              if BufPtr^[BufPos] = Ord(^J) then
                Inc(BufPos);
          end;

        end;

      until (CrPos <> $FFFF) or (alen > MaxWrdStr);

      {Return success and terminate the WrdStr}
      ReadLnWrdStr := True;

    end;
  end;

  function WriteWrdStr(var F : Text; var A : WrdStr) : Boolean;
    {-Write an WrdStr to text file, returning true if successful}
  var
    S : string;
    alen : Word absolute A;
    apos : Word;
    slen : Byte absolute S;
  begin
    apos := 1;
    WriteWrdStr := False;

    {Write the WrdStr as a series of strings}
    while apos < alen do begin
      slen := alen-apos;
      if slen > 255 then
        slen := 255;
      Move(A[apos], S[1], slen);
      Write(F, S);
      if IoResult <> 0 then
        Exit;
      Inc(apos, slen);
    end;

    WriteWrdStr := True;
  end;

end.